home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 9 / CDACTUAL9.iso / share / Dos / VARIOS / pascal / COMM.SWG / 0001_Minimal BBS System.pas next >
Encoding:
Pascal/Delphi Source File  |  1996-02-21  |  19.2 KB  |  765 lines
  1. {
  2. 3 Files:
  3.  
  4. PROTCOMM.PAS
  5. IO.PAS
  6. BBS.PAS
  7.  
  8. [-----------protcomm.pas begins----------------------------------------]
  9. { Origin - Mark Dignam of Omen Technologies  This unit has been highly modified }
  10.  
  11. Unit ProtComm;
  12.  
  13. Interface
  14.  
  15. Procedure SetBaud (NewRate : LongInt);
  16. Function  GetBaud : LongInt;
  17. Function  Comm_Init (Baud : LongInt;  ThePort : Byte) : Boolean;
  18. Procedure ModemDeInit;
  19. Procedure SetDTR (OnOff : Boolean);
  20. Function  SendReady: Boolean;
  21. Function  Carrier : Boolean;
  22. Function  DataAvailable : Boolean;
  23. Function  GetChar : Byte;
  24. Procedure HangUp;
  25. Function  Ringing : Boolean;
  26. Procedure SendByte (Ch : Char);
  27. Procedure AsyncFlushOutput;
  28. Procedure AsyncPurgeOutput;
  29. Procedure AsyncPurgeInput;
  30. Procedure SendBreak;
  31. Procedure CTS_RTS (OnOff : Boolean);
  32. Procedure AWrite (S : String);
  33. Procedure AWriteLn (S : String);
  34.  
  35. Var CanUseFossil : Boolean;
  36.     UsedPort     : Byte;
  37.  
  38. Implementation
  39.  
  40. Uses Crt, { Borland CRT Routines      }
  41.      Dos; { Borland Disk I/O Routines }
  42.  
  43. Const MaxPhysPort    = 7;
  44.       BufferSize     = 8196;
  45.       BufferMax      = 8195;
  46.       CommInterrupt  = $14 ;
  47.       I8088_IMR      = $21 ; { port address of the Interrupt Mask Register }
  48.       IBM_UART_THR         = $00 ;
  49.       IBM_UART_RBR         = $00 ;
  50.       IBM_UART_IER         = $01 ;
  51.       IBM_UART_IIR         = $02 ;
  52.       IBM_UART_LCR         = $03 ;
  53.       IBM_UART_MCR         = $04 ;
  54.       IBM_UART_LSR         = $05 ;
  55.       IBM_UART_MSR         = $06 ;
  56.       PortTable  : Array [0..MaxPhysPort] Of Record
  57.         Base : Word;
  58.         IRQ  : Byte
  59.       End = ( (Base : $3F8;  IRQ : 4),
  60.               (Base : $2F8;  IRQ : 3),
  61.               (Base : $3E8;  IRQ : 4),
  62.               (Base : $2E8;  IRQ : 3),
  63.               (Base : 0;  IRQ : 0),
  64.               (Base : 0;  IRQ : 0),
  65.               (Base : 0;  IRQ : 0),
  66.               (Base : 0;  IRQ : 0));
  67.  
  68. Var BIOS_Ports, IRQ                             : Byte;
  69.     Old_IER, Old_IIR, Old_LCR, Old_MCR, Old_IMR : Byte;
  70.     ExitSave, OriginalVector                    : Pointer;
  71.     IsOpen, OverFlow, UseFossil, CTS_RTS_On     : Boolean;
  72.     Base, BufferHead, BufferTail, BufferNewTail : Word;
  73.     Status, RxWord, CtsTimer                    : Word;
  74.     Buffer                                      : Array [0..BufferMax] Of
  75. Byte;    Regs                                        : Registers;
  76.  
  77. Procedure Comm_SetBios (NewRate : LongInt);
  78. Var BaudRate    : Byte;
  79.     Temp0       : Integer;
  80. Begin
  81.   {$IFNDEF TEST}
  82.   Temp0 := NewRate Div 10;
  83.   Case Temp0 of
  84.       30 : BaudRate := $43;
  85.       60 : BaudRate := $63;
  86.      120 : BaudRate := $83;
  87.      240 : BaudRate := $A3;
  88.      480 : BaudRate := $C3;
  89.      960 : BaudRate := $E3;
  90.     1920 : BaudRate := $03;
  91.     3840 : BaudRate := $23;
  92.     5760 : BaudRate := $23;
  93.   End;
  94.   Regs.AH := 0;
  95.   Regs.AL := BaudRate;
  96.   Regs.DX := UsedPort;
  97.   Intr ($14, Regs);
  98.   {$ENDIF}
  99. End;
  100.  
  101. Procedure Comm_SetDirect (NewRate : LongInt);
  102. Var I, J, K : Word;
  103.     Temp    : LongInt;
  104. Begin
  105.   {$IFNDEF TEST}
  106.   Temp := 115200;
  107.   Temp := Temp DIV Newrate;
  108.   Move (Temp, J, 2);
  109.   K := Port [IBM_UART_LCR + Base];
  110.   port [IBM_UART_LCR + Base] := $80;
  111.   Port [IBM_UART_THR + Base] := Lo (J);
  112.   Port [IBM_UART_IER + Base] := Hi (J);
  113.   Port [IBM_UART_LCR + Base] := 3;
  114.   {$ENDIF}
  115. End;
  116.  
  117. Procedure SetBaud (NewRate : LongInt);
  118. Begin
  119.   {$IFNDEF TEST}
  120.   If UseFossil Then Comm_SetBios (NewRate) Else Comm_SetDirect (NewRate);
  121.   {$ENDIF}
  122. End;
  123.  
  124. Function Getbaud : LongInt;
  125. Var I, J, K : Word;
  126.     Temp    : LongInt;
  127. begin
  128.   {$IFNDEF TEST}
  129.   K := Port [ibm_UART_LCR + Base];
  130.   Port [IBM_UART_LCR + Base] := K OR $80;
  131.   i := Port [IBM_UART_THR + Base];
  132.   J := Port [IBM_UART_IER + Base];
  133.   J := J * $100;
  134.   J := J + I;
  135.   Port [IBM_UART_LCR + base] := k;
  136.   Temp := 115200;
  137.   Temp := Temp DIV J;
  138.   GetBaud := Temp;
  139.   {$ELSE}
  140.   GetBaud := 4800;
  141.   {$ENDIF}
  142. End;
  143.  
  144. Function Carrier : Boolean;
  145. Begin
  146.   {$IFNDEF TEST}
  147.   Carrier := Port [IBM_UART_MSR + Base] AND $80 = $80;
  148.   {$ELSE}
  149.   Carrier := False;
  150.   {$ENDIF}
  151. End;
  152.  
  153. Procedure DisableInterrupts;  Inline ($FA);
  154. Procedure EnableInterrupts;   Inline ($FB);
  155.  
  156. Procedure ISR;  Interrupt;
  157. Begin
  158.   {$IFNDEF TEST}
  159.   Inline(
  160.     $FB/                                { sti                           }
  161.     {Start:                                                             }
  162.     { get the incoming character                                        }
  163.     { Buffer[BufferHead] := chr(port[base + ibm_uart_rbr]);             }
  164.     $8B/$16/Base/                       { mov dx,Base                   }
  165.     $EC/                                { in al,dx                      }
  166.     $8B/$1E/BufferHead/                 { mov bx,BufferHead             }
  167.     $88/$87/Buffer/                     { mov Buffer[bx],al             }
  168.     { BufferNewHead := Succ (BufferHead);                               }
  169.     $43/                                { inc bx                        }
  170.     { if BufferNewHead > BufferMax then BufferNewHead := 0 ;            }
  171.     $81/$FB/BufferMax/                  { cmp bx,BufferMax              }
  172.     $7E/$02/                            { jle l001                      }
  173.     $33/$DB/                            { xor bx,bx                     }
  174.     { if BufferNewHead = BufferTail then Overflow := true               }
  175.     {L001:                                                              }
  176.     $3B/$1E/BufferTail/                 { cmp bx,BufferTail             }
  177.     $75/$07/                            { jne L002                      }
  178.     $C6/$06/Overflow/$01/               { mov overflow,1                }
  179.     $EB/$0E/                            { jmp short L003                }
  180.     { ELSE BEGIN                                                        }
  181.     {   BufferHead := BufferNewHead;                                    }
  182.     {   Async_BufferUsed := succ(Async_BufferUsed);                     }
  183.     {   IF Async_BufferUsed > Async_MaxBufferUsed then                  }
  184.     {     Async_MaxBufferUsed := Async_BufferUsed                       }
  185.     {   END ;                                                           }
  186.     {L002:                                                              }
  187.     $89/$1E/BufferHead/                 { mov BufferHead,bx             }
  188.     $83/$C2/$05/                        { Add dx,5                      }
  189.     { Check FIFO - And process if more bytes.                           }
  190.     $EC/                                { In al,dx                      }
  191.     $24/$01/                            { And al,$01                    }
  192.     $3C/$01/                            { cmp al,$01                    }
  193.     $74/$CF/                            { je start:                     }
  194.     {L003:                                                              }
  195.     $FA/                                { cli                           }
  196.     { issue non-specific EOI                                            }
  197.     { port[$20] := $20 ;                                                }
  198.     $B0/$20/                            { mov al,20h                    }
  199.     $E6/$20);                           { out 20h,al                    }
  200.   {$ENDIF}
  201. End;
  202.  
  203. Procedure Async_Close;
  204. Begin
  205.   {$IFNDEF TEST}
  206.   If IsOpen Then
  207.   Begin
  208.     DisableInterrupts;
  209.     Port [I8088_IMR] := (Port[I8088_IMR] OR (1 SHL IRQ));
  210.     Port [IBM_UART_IER + Base] := Old_IER;
  211.     EnableInterrupts;
  212.     Port [IBM_UART_MCR + Base] := Old_MCR;
  213.     Port [IBM_UART_LCR + Base] := Old_lCR;
  214.     SetIntVec (IRQ + 8, OriginalVector);
  215.     IsOpen := False;
  216.   End;
  217.   {$ENDIF}
  218. End;
  219.  
  220. Function Init_fossil (Baud : LongInt;  ThePort : Byte) : Boolean;
  221. Begin
  222.   {$IFNDEF TEST}
  223.   UsedPort := ThePort - 1;
  224.   Regs.AH := 4;
  225.   Regs.DX := UsedPort;
  226.   Intr ($14, Regs);
  227.   If Regs.AX <> $1954 Then Init_Fossil := False Else
  228.   Begin
  229.     Init_Fossil := True;
  230.     UseFossil := True;
  231.     SetBaud (Baud);
  232.   End;
  233.   {$ELSE}
  234.   Init_Fossil := True;
  235.   {$ENDIF}
  236. End;
  237.  
  238. Function Async_Open(Baud : Longint; LogicalPortNum: byte): boolean;
  239. Var I, OldIIR        : Byte;
  240.     Fifos, PortThere : Boolean;
  241. Begin
  242.   {$IFNDEF TEST}
  243.   If Not IsOpen Then
  244.   Begin
  245.     BufferHead := 0;
  246.     BufferTail := 0;
  247.     Overflow := False;
  248.     UsedPort := Pred (LogicalPortNum);
  249.     Fifos := False;
  250.     IsOpen := False;
  251.     If PortTable [UsedPort].Base <> 0 Then
  252.     Begin
  253.       Base := PortTable [UsedPort].Base;
  254.       IRQ := PortTable [UsedPort].IRQ;
  255.       Old_IER := Port [IBM_UART_IER + Base];
  256.       Old_MCR := Port [IBM_UART_MCR + Base];
  257.       Old_LCR := Port [IBM_UART_LCR + Base];
  258.       Port [IBM_UART_LCR + Base] := $75;
  259.       PortThere := (Port [IBM_UART_LCR + Base] = $75);
  260.       Port [IBM_UART_LCR + Base] := $3;
  261.       If PortThere Then
  262.       Begin
  263.         Comm_SetDirect (Baud);
  264.         Port [IBM_UART_MCR + Base] := $0B;
  265.         OldIIR := Port [IBM_UART_IIR + Base];
  266.         Port [IBM_UART_IIR + Base] := 1;
  267.         Fifos := (Port [IBM_UART_IIR + Base] AND $C0 = $C0);
  268.         If Not Fifos Then Port [IBM_UART_IIR + Base] := OldIIR;
  269.         GetIntVec (IRQ + 8, OriginalVector);
  270.         SetIntVec (IRQ + 8, @ISR);
  271.         DisableInterrupts;
  272.         Port [I8088_IMR] := (Port [I8088_IMR] AND ((1 SHL IRQ) XOR $FF));
  273.         Port [IBM_UART_IER + Base] := 1;
  274.         EnableInterrupts;
  275.         IsOpen := True;
  276.       End;
  277.     End;
  278.   End;
  279.   Async_Open := IsOpen
  280.   {$ELSE}
  281.   Async_Open := True;
  282.   {$ENDIF}
  283. End;
  284.  
  285. {$F+}
  286. Procedure TerminateUnit;
  287. {$F-}
  288.  
  289. Begin
  290.   Async_Close;
  291.   ExitProc := ExitSave
  292. End;
  293.  
  294. Function Comm_init (Baud : Longint; ThePort : Byte) : Boolean;
  295. Begin
  296.   {$IFNDEF TEST}
  297.   UseFossil := False;
  298.   If Not IsOpen Then
  299.   Begin
  300.     If (CanUseFossil) AND (Init_Fossil (Baud, ThePort)) Then
  301.     Begin
  302.       Comm_Init := True;
  303.       IsOpen := True;
  304.       Base := PortTable [UsedPort].Base;
  305.     End Else
  306.     Begin
  307.       If Async_Open (Baud, ThePort) Then
  308.       Begin
  309.         Comm_Init := true;
  310.         IsOpen := True;
  311.       End Else Comm_Init := False;
  312.     End;
  313.   End;
  314.   UsedPort := ThePort;
  315.   {$ELSE}
  316.   Comm_Init := True;
  317.   {$ENDIF}
  318. End;
  319.  
  320. Function DataAvailable : Boolean;
  321. Var AHigh : Byte;
  322. Begin
  323.   {$IFNDEF TEST}
  324.   If UseFossil Then
  325.   Begin
  326.     Inline ($B4/$03/            { MOV AH, 3        }
  327.             $8b/$16/UsedPort/   { MOV DX, Usedport }
  328.             $cd/$14/            { INT 14h          }
  329.             $a3/Status);        { MOV [Status], AL }
  330.     DataAvailable := ((Status AND $100) <> 0);
  331.   End Else DataAvailable := (Bufferhead <> BufferTail);
  332.   {$ELSE}
  333.   DataAvailable := False;
  334.   {$ENDIF}
  335. End;
  336.  
  337. Procedure ModemDeInit;
  338. Begin
  339.   {$IFNDEF TEST}
  340.   If IsOpen Then
  341.   Begin
  342.     If UseFossil Then
  343.     Begin
  344.       Regs.AH := 5;
  345.       Regs.DX := UsedPort;
  346.       Intr ($14, Regs);
  347.     End Else Async_Close;
  348.     IsOpen := False;
  349.   End;
  350.   {$ENDIF}
  351. End;
  352.  
  353. Function GetChar : byte;
  354. Begin
  355.   {$IFNDEF TEST}
  356.   If UseFossil Then
  357.   Begin
  358.     Inline ($B4/$02/            { MOV AH, 3        }
  359.             $8b/$16/UsedPort/   { MOV Dx, Usedport }
  360.             $CD/$14/            { INT 14h          }
  361.             $A3/RXWord);        { Mov [Status], AL }
  362.     GetChar := Lo (RXWord);
  363.   End Else
  364.   Begin
  365.     GetChar := Buffer [BufferTail] ;
  366.     BufferTail := (Succ (BufferTail) MOD BufferSize) ;
  367.   End;
  368.   {$ENDIF}
  369. End;
  370.  
  371. Function SendReady : boolean;
  372. Var Ahigh          : Byte;
  373.     Carr, CTS, THR : boolean;
  374. Begin
  375.   {$IFNDEF TEST}
  376.   If UseFossil Then
  377.   Begin
  378.     Inline ($B4/$03/            { MOV AH, 3        }
  379.             $8B/$16/UsedPort/   { MOV DX, Usedport }
  380.             $CD/$14/            { INT 14h          }
  381.             $A3/Status);        { MOV Status, AX   }
  382.     THR  := (Status AND $2000) <> 0;
  383.     Carr := (Status AND $0080) <> 0;
  384.     SendReady := THR OR (Not Carr);
  385.  
  386.   End Else
  387.   Begin
  388.     THR := ((Port [IBM_UART_LSR + Base] AND $20) <> 0);
  389.     CTS :=  (Port [IBM_UART_MSR + Base] AND $10 = $10);
  390.     If CTS_RTS_On AND Carrier Then SendReady := THR AND Cts Else SendReady :=
  391. THR;  End;
  392.   {$ELSE}
  393.   SendReady := False;
  394.   {$ENDIF}
  395. End;
  396.  
  397. Procedure SendByte (Ch : Char);
  398. Begin
  399.   {$IFNDEF TEST}
  400.   Repeat Until SendReady;
  401.   If UseFossil then
  402.   Begin
  403.     Regs.AH := 1;
  404.     Regs.AL := Ord (Ch);
  405.     Regs.DX := UsedPort;
  406.     intr($14,regs);
  407.   End Else Port [IBM_UART_THR + Base] := Ord (Ch);
  408.   {$ENDIF}
  409. End;
  410.  
  411. Procedure AsyncFlushOutput;
  412. Begin
  413.   {$IFNDEF TEST}
  414.   If Usefossil Then
  415.   Begin
  416.     Regs.AH := 8;
  417.     Regs.DX := UsedPort;
  418.     Intr ($14, Regs);
  419.   End;
  420.   {$ENDIF}
  421. End;
  422.  
  423.  
  424. Procedure AsyncPurgeOutput;
  425. Begin
  426.   {$IFNDEF TEST}
  427.   If UseFossil Then
  428.   Begin
  429.     Regs.AH := 9;
  430.     Regs.DX := UsedPort;
  431.     Intr ($14, Regs);
  432.   End;
  433.   {$ENDIF}
  434. End;
  435.  
  436. Procedure AsyncPurgeInput;
  437. Begin
  438.   {$IFNDEF TEST}
  439.   If UseFossil then
  440.   Begin
  441.     Regs.AH := $0A;
  442.     Regs.DX := UsedPort;
  443.     Intr ($14, Regs);
  444.   End Else
  445.   Begin
  446.     BufferHead := 0;
  447.     BufferTail := 0;
  448.     OverFlow   := False;
  449.   End;
  450.   {$ENDIF}
  451. End;
  452.  
  453. Procedure SendBreak;
  454. Var I, J : Byte;
  455. Begin
  456.   {$IFNDEF TEST}
  457.   If UseFossil then
  458.   Begin
  459.     Regs.AX := $1A01;
  460.     Regs.DX := UsedPort;
  461.     Intr ($14, Regs);
  462.     Delay (100);
  463.     Regs.AX := $1A00;
  464.     Regs.DX := UsedPort;
  465.     Intr ($14, Regs);
  466.   End Else
  467.   Begin
  468.     I := Port [IBM_UART_LCR + Base];
  469.     J := I;
  470.     I := I AND $7F;
  471.     I := I OR $40;
  472.     Port [IBM_UART_LCR + Base] := I;
  473.     delay (100);
  474.     Port [IBM_UART_LCR + Base] := J;
  475.   End;
  476.   {$ENDIF}
  477. End;
  478.  
  479. Procedure SetDTR (OnOff : Boolean);
  480. Var I : Byte;
  481. Begin
  482.   {$IFNDEF TEST}
  483.   If UseFossil then
  484.   Begin
  485.     Regs.AH := $06;
  486.     If OnOff Then Regs.AL := 1 Else Regs.AL := 0;
  487.     Regs.DX := UsedPort;
  488.     Intr ($14, Regs);
  489.   End Else
  490.   Begin
  491.     If OnOff Then Port [IBM_UART_MCR + Base] := $0B Else Port [IBM_Uart_MCR +
  492. Base] := $0A;  End;
  493.   {$ENDIF}
  494. End;
  495.  
  496. Procedure CTS_RTS (OnOff : Boolean);
  497. Begin
  498.   {$IFNDEF TEST}
  499.   If UseFossil Then
  500.   Begin
  501.     Regs.DX := UsedPort;
  502.     If OnOff Then Regs.AL := 2 Else Regs.AL := 0;
  503.     Regs.AH := $0F;
  504.     Intr ($14, Regs);
  505.   End Else CTS_RTS_On := OnOff;
  506.   {$ENDIF}
  507. End;
  508.  
  509. Procedure AWrite (S : String);
  510. Var I : Integer;
  511. Begin
  512.   {$IFNDEF TEST}
  513.   For I := 1 To Length (S) Do SendByte ((S[I]));
  514.   {$ENDIF}
  515. End;
  516.  
  517. Procedure AWriteLn (S : String);
  518. Begin
  519.   {$IFNDEF TEST}
  520.   AWrite (S + #10#13);
  521.   {$ENDIF}
  522. End;
  523.  
  524. Function Ringing : Boolean;
  525. Begin
  526.   {$IFNDEF TEST}
  527.   Case UsedPort of
  528.     1 : Ringing := Boolean (Port[$3FE] And 64);
  529.     2 : Ringing := Boolean (Port[$2FE] And 64);
  530.     3 : Ringing := Boolean (Port[$3EE] And 64);
  531.     4 : Ringing := Boolean (Port[$2EE] And 64);
  532.     Else Ringing := False;
  533.   End;
  534.   {$ELSE}
  535.   Ringing := False;
  536.   {$ENDIF}
  537. End;
  538.  
  539. Procedure Hangup;
  540. Begin
  541.   {$IFNDEF TEST}
  542.   SetDTR (False);
  543.   Delay (250);
  544.   SetDTR (True);
  545.   {$ENDIF}
  546. End;
  547.  
  548. Begin
  549.   {$IFNDEF TEST}
  550.   ExitSave := ExitProc;
  551.   ExitProc := @TerminateUnit;
  552.   IsOpen   := FALSE;
  553.   Overflow := FALSE;
  554.   CanUseFossil := False;
  555.   CTS_RTS_On := True;
  556.   Bios_Ports := 4;
  557.   {$ENDIF}
  558. End.
  559.  
  560. [-----------protcomm.pas ends -------------------------------------------------]
  561. [-----------io.pas begins-----------------------------------------------------]
  562. Unit IO;
  563.  
  564. Interface
  565.  
  566. Procedure SWrite         (S : String);
  567. Procedure SWriteLn       (S : String);
  568. Procedure SReadLn        (Var S : String);
  569. Procedure SClrScr;
  570.  
  571. Var Local : Boolean;
  572.  
  573. Implementation
  574.  
  575. Uses Crt, ProtComm;
  576.  
  577. Procedure SWrite (S : String);
  578. Begin
  579.   Write (S);
  580.   If Not Local Then AWrite (S);
  581. End;
  582.  
  583. Procedure SWriteLn (S : String);
  584. Begin
  585.   WriteLn (S);
  586.   If Not Local Then AWriteLn (S);
  587. End;
  588.  
  589. Function SReadKey : Char;
  590. Var Done : Boolean;
  591.     Ch   : Char;
  592. Begin
  593.   Done := False;
  594.   Repeat
  595.     If (Not Local) and (Not Carrier) Then Done := True;
  596.     If Not Local Then
  597.     If DataAvailable Then
  598.     Begin
  599.       Ch := Chr (GetChar);
  600.       Done := True;
  601.     End;
  602.     If KeyPressed Then
  603.     Begin
  604.       Ch := ReadKey;
  605.       Done := True;
  606.     End;
  607.   Until Done;
  608.   SReadKey := Ch;
  609. End;
  610.  
  611. Function SKeyPressed : Boolean;
  612. Begin
  613.   SKeyPressed := False;
  614.   If DataAvailable Then SKeyPressed := True;
  615.   If KeyPressed Then SKeyPressed := True;
  616. End;
  617.  
  618. Procedure SReadLn (Var S : String);
  619. Var Ch : Char;
  620. Begin
  621.   S := '';
  622.   Repeat
  623.     Ch := SReadKey;
  624.     If Ord (Ch) in [32..122] Then
  625.     Begin
  626.       S := S + Ch;
  627.       SWrite (Ch);
  628.     End;
  629.     If Ord (Ch) = Ord (8) Then
  630.     Begin
  631.       If Length (S) > 0 Then
  632.       Begin
  633.         SWrite (#8' '#8);
  634.         Delete (S, Length (S), 1);
  635.       End;
  636.     End;
  637.   Until (Ord (Ch) = 13) OR ((Not Carrier) AND (Not Local));
  638.   SWrite (#13#10);
  639. End;
  640.  
  641. Procedure SClrScr;
  642. Begin
  643.   SWriteLn (#12);
  644.   ClrScr;
  645. End;
  646.  
  647. End.
  648. [-----------io.pas ends-------------------------------------------------]
  649. [-----------bbs.pas begins ---------------------------------------------]
  650. { Minimal BBS - part of the Communications Package of HTCPACK #7
  651.   For more information or for information on where to obtain complete
  652. HTCPACK's  email havoc.the.chaos@iirg.com }
  653.  
  654. Uses Crt, IO, ProtComm;
  655.  
  656. Var TestPad : String;
  657.     OutChar : Char;
  658.  
  659. Procedure RunBBS;
  660. Var Answer : String;
  661. Begin
  662.   SWriteLn ('Welcome to the minimal BBS!');
  663.   SWrite ('Type somethin: ');
  664.   SReadLn (Answer);
  665.   SWriteLn ('You typed "' + Answer + '"');
  666.   Delay (5000);
  667.   SWriteLn ('Goodbye!');
  668.   AsyncFlushOutput;
  669.   Hangup;
  670. End;
  671.  
  672. Procedure FrontEnd;
  673. Var EscPressed : Boolean;
  674.     ModemString : String;
  675.     Timer : Integer;
  676.     Ch : Char;
  677. Begin
  678.   If Not Local Then AWriteLn ('ATA');
  679.   ClrScr;
  680.   WriteLn ('*** RING ***'#7);
  681.   ModemString := '';
  682.   EscPressed := False;
  683.   If Not Local Then
  684.   Begin
  685.     AsyncPurgeInput;
  686.     Timer := 0;
  687.     EscPressed := False;
  688.     Repeat
  689.       ModemString := '';
  690.       While DataAvailable Do ModemString := ModemString + Chr (GetChar);
  691.       Delay (1);
  692.       Inc (Timer);
  693.       If KeyPressed Then
  694.       Begin
  695.         Ch := ReadKey;
  696.         If Ord (Ch) = Ord (27) Then EscPressed := True;
  697.       End;
  698.     Until (Carrier) or (Timer = 60000) or (Local) or (EscPressed);
  699.   End;
  700.   If EscPressed OR (Timer = 60000) Then
  701.   Begin
  702.     ClrScr;
  703.     AWriteLn ('');
  704.     Write ('Connection not established due to ');
  705.     If EscPressed Then WriteLn ('local escape.');
  706.     If Timer = 60000 Then WriteLn ('a 60 time elapse with no connection.');
  707.     Delay (2000);
  708.     Exit;
  709.   End;
  710.   If Carrier OR Local Then
  711.   Begin
  712.     While KeyPressed Do Write (ReadKey, #8);
  713.     AsyncPurgeInput;
  714.     RunBBS;
  715.   End;
  716. End;
  717.  
  718. Procedure Initialize;
  719. Begin
  720.   Comm_Init (57600, 2);
  721.   ClrScr;
  722.   Local := False;
  723.   AsyncPurgeInput;
  724.   While DataAvailable Do Write (Chr (GetChar));
  725.   If Not Carrier Then AWriteLn ('ATZ');
  726. End;
  727.  
  728. Begin
  729.   Initialize;
  730.   Repeat
  731.     TestPad := '';
  732.     While DataAvailable Do
  733.     Begin
  734.       TestPad := TestPad + Chr (GetChar);
  735.     End;
  736.     TestPad := '';
  737.     If Ringing Then
  738.     Begin
  739.       Local := False;
  740.       FrontEnd;
  741.     End;
  742.     If KeyPressed Then
  743.     Begin
  744.       OutChar := ReadKey;
  745.       Case Ord (OutChar) of
  746.          0 : Begin
  747.                OutChar := ReadKey;
  748.                Case Ord (OutChar) of
  749. {F1}             59 : Begin
  750.                         Local := True;
  751.                         FrontEnd;
  752.                       End;
  753. {ALT-X}          45 : Begin
  754.                         ModemDeInit;
  755.                         Halt;
  756.                       End;
  757.                End;
  758.              End;
  759.       End;
  760.     End;
  761.   Until 1 = 2;
  762. End.
  763.  
  764. [-----------bbs.pas ends-------------------------------------------------]
  765.